home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RTT.ZIP / RTTDB.C < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-10  |  42.3 KB  |  1,489 lines
  1. /*
  2.  * rttdb.c - routines to read, manipulate, and write the data base of
  3.  *  information about run-time routines.
  4.  */
  5.  
  6. #include "rtt.h"
  7. #include "../h/version.h"
  8.  
  9. #define DHSize 47
  10. #define MaxLine 80
  11.  
  12. /*
  13.  * prototypes for static functions.
  14.  */
  15. hidden novalue max_pre   Params((struct implement **tbl, char *pre));
  16. hidden int     name_cmp  Params((char *p1, char *p2));
  17. hidden int     op_cmp    Params((char *p1, char *p2));
  18. hidden novalue prt_dpnd  Params((FILE *db));
  19. hidden novalue prt_impls Params((FILE *db, char *sect, struct implement **tbl,
  20.                            int num, struct implement **sort_ary, int (*com)()));
  21. hidden int     prt_c_fl  Params((FILE *db, struct cfile *clst, int line_left));
  22. hidden int     put_case  Params((FILE *db, struct il_code *il));
  23. hidden novalue put_ilc   Params((FILE *db, struct il_c *ilc));
  24. hidden novalue put_inlin Params((FILE *db, struct il_code *il));
  25. hidden novalue put_ret   Params((FILE *db, struct il_c *ilc));
  26. hidden novalue put_typcd Params((FILE *db, int typcd));
  27. hidden novalue put_var   Params((FILE *db, int code, struct il_c *ilc));
  28. hidden novalue ret_flag  Params((FILE *db, int flag, int may_fthru));
  29. hidden int     set_impl  Params((struct token *name, struct implement **tbl,
  30.                            int num_impl, char *pre));
  31. hidden novalue set_prms  Params((struct implement *ptr));
  32. hidden int     src_cmp   Params((char *p1, char *p2));
  33.  
  34. static struct implement *bhash[IHSize];    /* hash area for built-in func table */
  35. static struct implement *ohash[IHSize]; /* hash area for operator table */
  36. static struct implement *khash[IHSize];    /* hash area for keyword table */
  37.  
  38. static struct srcfile *dhash[DHSize];    /* hash area for file dependencies */
  39.  
  40. static int num_fnc;        /* number of function in data base */
  41. static int num_op = 0;        /* number of operators in data base */
  42. static int num_key;        /* number of keywords in data base */
  43. static int num_src = 0;        /* number of source files in depedancies */
  44.  
  45. static char fnc_pre[2];        /* next prefix available for functions */
  46. static char op_pre[2];        /* next prefix available for operators */
  47. static char key_pre[2];        /* next prefix available for keywords */
  48.  
  49. static long min_rs;        /* min result sequence of current operation */
  50. static long max_rs;        /* max result sequence of current operation */
  51. static int rsm_rs;        /* '+' at end of result sequene of cur. oper. */
  52.  
  53. static int newdb = 0;        /* flag: this is a new data base */
  54. struct token *comment;        /* comment associated with current operation */
  55. struct implement *cur_impl;    /* data base entry for current operation */
  56.  
  57. /*
  58.  * loaddb - load data base.
  59.  */
  60. novalue loaddb(dbname)
  61. char *dbname;
  62.    {
  63.    char *op;
  64.    struct implement *ip;
  65.    unsigned hashval;
  66.    int i;
  67.    char *srcname;
  68.    char *c_name;
  69.    struct srcfile *sfile;
  70.  
  71.  
  72.    /*
  73.     * Initialize internal data base.
  74.     */
  75.    for (i = 0; i < IHSize; i++) {
  76.        bhash[i] = NULL;   /* built-in function table */
  77.        ohash[i] = NULL;   /* operator table */
  78.        khash[i] = NULL;   /* keyword table */
  79.        }
  80.    for (i = 0; i < DHSize; i++)
  81.        dhash[i] = NULL;   /* dependency table */
  82.  
  83.    /*
  84.     * Determine if this is a new data base or an existing one.
  85.     */
  86.    if (iconx_flg || !db_open(dbname, &largeints))
  87.       newdb = 1;
  88.    else {
  89.  
  90.       /*
  91.        * Read information about built-in functions.
  92.        */
  93.       num_fnc = db_tbl("functions", bhash);
  94.  
  95.       /*
  96.        * Read information about operators.
  97.        */
  98.       db_chstr("", "operators");    /* verify and skip "operators" */
  99.  
  100.       while ((op = db_string()) != NULL) {
  101.          /*
  102.           * Read header information for the operator.
  103.            */
  104.          if ((ip = db_impl('O')) == NULL)
  105.             db_err2(1, "no implementaion information for operator", op);
  106.          ip->op = op;
  107.  
  108.          /*
  109.           * Read the descriptive comment and in-line code for the operator,
  110.           *  then put the entry in the hash table.
  111.           */
  112.          db_code(ip);
  113.          hashval = IHasher(op);
  114.          ip->blink = ohash[hashval];
  115.          ohash[hashval] = ip;
  116.          db_chstr("", "end");         /* verify and skip "end" */
  117.          ++num_op;
  118.          }
  119.       db_chstr("", "endsect");       /* verify and skip "endsect" */
  120.  
  121.       /*
  122.        * Read information about keywords.
  123.        */
  124.       num_key = db_tbl("keywords", khash);
  125.  
  126.       /*
  127.        * Read C file/source dependency information.
  128.        */
  129.       db_chstr("", "dependencies");  /* verify and skip "dependencies" */
  130.  
  131.       while ((srcname = db_string()) != NULL) {
  132.          sfile = src_lkup(srcname);
  133.          while ((c_name = db_string()) != NULL)
  134.             add_dpnd(sfile, c_name);
  135.          db_chstr("", "end");         /* verify and skip "end" */
  136.          }
  137.       db_chstr("", "endsect");        /* verify and skip "endsect" */
  138.  
  139.       db_close();
  140.       }
  141.  
  142.    /*
  143.     * Determine the next available operation prefixes by finding the
  144.     *  maximum prefixes currently in use.
  145.     */
  146.    max_pre(bhash, fnc_pre);
  147.    max_pre(ohash, op_pre);
  148.    max_pre(khash, key_pre);
  149.    }
  150.  
  151. /*
  152.  * max_pre - find the maximum prefix in an implemetation table and set the
  153.  *  prefix array to the next value.
  154.  */
  155. static novalue max_pre(tbl, pre)
  156. struct implement **tbl;
  157. char *pre;
  158.    {
  159.    register struct implement *ptr;
  160.    unsigned hashval;
  161.    int empty = 1;
  162.    char dmy_pre[2];
  163.  
  164.    pre[0] = '0';
  165.    pre[1] = '0';
  166.    for (hashval = 0; hashval < IHSize; ++hashval) 
  167.       for (ptr = tbl[hashval]; ptr != NULL; ptr = ptr->blink) {
  168.          empty = 0;
  169.          /*
  170.           * Determine if this prefix is larger than any found so far.
  171.           */
  172.          if (cmp_pre(ptr->prefix, pre) > 0) {
  173.             pre[0] = ptr->prefix[0];
  174.             pre[1] = ptr->prefix[1];
  175.             }
  176.          }
  177.    if (!empty)
  178.       nxt_pre(dmy_pre, pre);
  179.    }
  180.  
  181.  
  182. /*
  183.  * src_lkup - return pointer to dependency information for the given
  184.  *   source file.
  185.  */
  186. struct srcfile *src_lkup(srcname)
  187. char *srcname;
  188.    {
  189.    unsigned hashval;
  190.    struct srcfile *sfile;
  191.  
  192.    /*
  193.     * See if the source file is already in the depedancy section of
  194.     *  the data base.
  195.     */
  196.    hashval = (unsigned)srcname % DHSize;
  197.    for (sfile = dhash[hashval]; sfile != NULL && sfile->name != srcname;
  198.         sfile = sfile->next)
  199.       ;
  200.  
  201.    /*
  202.     * If an entry for the source file was not found, create one.
  203.     */
  204.    if (sfile == NULL) {
  205.       sfile = NewStruct(srcfile);
  206.       sfile->name = srcname;
  207.       sfile->dependents = NULL;
  208.       sfile->next = dhash[hashval];
  209.       dhash[hashval] = sfile;
  210.       ++num_src;
  211.       }
  212.    return sfile;
  213.    }
  214.  
  215. /*
  216.  * add_dpnd - add the given source/dependency relation to the dependency
  217.  *   table.
  218.  */
  219. novalue add_dpnd(sfile, c_name)
  220. struct srcfile *sfile;
  221. char *c_name;
  222.    {
  223.    struct cfile *cf;
  224.  
  225.    cf = NewStruct(cfile);
  226.    cf->name = c_name;
  227.    cf->next = sfile->dependents;
  228.    sfile->dependents = cf;
  229.    }
  230.  
  231. /*
  232.  * clr_dpnd - delete all dependencies for the given source file.
  233.  */
  234. novalue clr_dpnd(srcname)
  235. char *srcname;
  236.    {
  237.    src_lkup(srcname)->dependents = NULL;
  238.    }
  239.  
  240. /*
  241.  * dumpdb - write the updated data base.
  242.  */
  243. novalue dumpdb(dbname)
  244. char *dbname;
  245.    {
  246. #ifdef Rttx
  247.    fprintf(stdout, "rtt was compiled to only support the intepreter, use -x\n");
  248.    exit(ErrorExit);
  249. #else                    /* Rttx */
  250.    FILE *db;
  251.    struct implement **sort_ary;
  252.    int ary_sz;
  253.  
  254.    db = fopen(dbname, "w");
  255.    if (db == NULL)
  256.       err2("cannot open data base for output:", dbname);
  257.    if(newdb)
  258.       fprintf(stdout, "creating new data base: %s\n", dbname);
  259.  
  260.    /*
  261.     * The data base starts with a version number assciated with this
  262.     *   version of rtt and an indication of whether LargeInts was
  263.     *   defined during the build.
  264.     */
  265.    fprintf(db, "%s %s\n\n", DVersion, largeints);
  266.  
  267.    /*
  268.     * Allocate an array for sorting operation entries. It must be
  269.     *   large enough to hold functions, operators, or keywords.
  270.     */
  271.    ary_sz = Max(num_fnc, num_op);
  272.    ary_sz = Max(ary_sz, num_key);
  273.    sort_ary =
  274.     (struct implement**)alloc((unsigned int)(ary_sz*sizeof(struct implement*)));
  275.  
  276.    /*
  277.     * Sort and print to the data base the enties for each of the
  278.     *   three operation sections.
  279.     */
  280.    prt_impls(db, "functions", bhash, num_fnc, sort_ary, name_cmp);
  281.    prt_impls(db, "\noperators", ohash, num_op, sort_ary, op_cmp);
  282.    prt_impls(db, "\nkeywords", khash, num_key, sort_ary, name_cmp);
  283.    free((char *)sort_ary);
  284.  
  285.    /*
  286.     * Print the dependancy information to the data base.
  287.     */
  288.    prt_dpnd(db);
  289.    fclose(db);
  290. #endif                    /* Rttx */
  291.    }
  292.  
  293. #ifndef Rttx
  294. /*
  295.  * prt_impl - sort and print to the data base the enties from one
  296.  *   of the operation tables.
  297.  */
  298. static novalue prt_impls(db, sect, tbl, num, sort_ary, cmp)
  299. FILE *db;
  300. char *sect;
  301. struct implement **tbl;
  302. int num;
  303. struct implement **sort_ary;
  304. int (*cmp)();
  305.    {
  306.    int i;
  307.    int j;
  308.    unsigned hashval;
  309.    struct implement *ip;
  310.  
  311.    /*
  312.     * Each operation section begins with the section name.
  313.     */
  314.    fprintf(db, "%s\n\n", sect);
  315.  
  316.    /*
  317.     * Sort the table entries before printing.
  318.     */
  319.    i = 0;
  320.    for (hashval = 0; hashval < IHSize; ++hashval)
  321.       for (ip = tbl[hashval]; ip != NULL; ip = ip->blink)
  322.          sort_ary[i++] = ip;
  323.    qsort((char *)sort_ary, num, sizeof(struct implement *), cmp);
  324.  
  325.    /*
  326.     * Output each entry to the data base.
  327.     */
  328.    for (i = 0; i < num; ++i) {
  329.       ip = sort_ary[i];
  330.  
  331.       /*
  332.        * Operators have operator symbols.
  333.        */
  334.       if (ip->op != NULL)
  335.          fprintf(db, "%s\t", ip->op);
  336.  
  337.       /*
  338.        * Print the operation name, the unique prefix used to generate
  339.        *   C function names, and the number of parameters to the operation.
  340.        */
  341.       fprintf(db, "%s\t%c%c %d(", ip->name, ip->prefix[0], ip->prefix[1],
  342.          ip->nargs);
  343.  
  344.       /*
  345.        * For each parameter, write and indication of whether a dereferenced
  346.        *   value, 'd', and/or and undereferenced value, 'u', is needed.
  347.        */
  348.       for (j = 0; j < ip->nargs; ++j) {
  349.          if (j > 0)
  350.             fprintf(db, ",");
  351.          if (ip->arg_flgs[j] & RtParm)
  352.             fprintf(db, "u");
  353.          if (ip->arg_flgs[j] & DrfPrm)
  354.             fprintf(db, "d");
  355.          }
  356.  
  357.       /*
  358.        * Indicate if the last parameter represents the tail of a
  359.        *   variable length argument list.
  360.        */
  361.       if (ip->nargs > 0 && ip->arg_flgs[ip->nargs - 1] & VarPrm)
  362.          fprintf(db, "v");
  363.       fprintf(db, ")\t{");
  364.  
  365.       /*
  366.        * Print the min and max result sequence length.
  367.        */
  368.       if (ip->min_result != NoRsltSeq) {
  369.          fprintf(db, "%ld,", ip->min_result);
  370.          if (ip->max_result == UnbndSeq)
  371.             fprintf(db, "*");
  372.          else
  373.             fprintf(db, "%ld", ip->max_result);
  374.          if (ip->resume)
  375.             fprintf(db, "+");
  376.          }
  377.       fprintf(db, "} ");
  378.  
  379.       /*
  380.        * Print the return/suspend/fail/fall-through flag and an indication
  381.        *   of whether the operation explicitly uses the result location
  382.        *   (as opposed to an implicit use via return or suspend).
  383.        */
  384.       ret_flag(db, ip->ret_flag, 0);
  385.       if (ip->use_rslt)
  386.          fprintf(db, "t ");
  387.       else
  388.          fprintf(db, "f ");
  389.  
  390.       /*
  391.        * Print the descriptive comment associated with the operation.
  392.        */
  393.       fprintf(db, "\n\"%s\"\n", ip->comment);
  394.  
  395.       /*
  396.        * Print information about tended declarations from the declare
  397.        *  statement. The number of tended variables is printed followed
  398.        *  by an entry for each variable. Each entry consists of the
  399.        *  type of the declaration
  400.        * 
  401.        *     struct descrip  -> desc
  402.        *     char *          -> str
  403.        *     struct b_xxx *  -> blkptr b_xxx
  404.        *     union block *   -> blkptr *
  405.        *
  406.        *  followed by the C code for the initializer (nil indicates none).
  407.        */
  408.       fprintf(db, "%d ", ip->ntnds);
  409.       for (j = 0; j < ip->ntnds; ++j) {
  410.          switch (ip->tnds[j].var_type) {
  411.             case TndDesc:
  412.                fprintf(db, "desc ");
  413.                break;
  414.             case TndStr:
  415.                fprintf(db, "str ");
  416.                break;
  417.             case TndBlk:
  418.                fprintf(db, "blkptr ");
  419.                if (ip->tnds[j].blk_name == NULL)
  420.                   fprintf(db, "* ");
  421.                else
  422.                   fprintf(db, "%s ", ip->tnds[j].blk_name);
  423.                break;
  424.             }
  425.          put_ilc(db, ip->tnds[j].init);
  426.          }
  427.  
  428.       /*
  429.        * Print information about non-tended declarations from the declare
  430.        *  statement. The number of variables is printed followed by an
  431.        *  entry for each varaible. Each entry consists of the variable
  432.        *  name followed by the complete C code for the declaration.
  433.        */
  434.       fprintf(db, "\n%d ", ip->nvars);
  435.       for (j = 0; j < ip->nvars; ++j) {
  436.          fprintf(db, "%s ", ip->vars[j].name);
  437.          put_ilc(db, ip->vars[j].dcl);
  438.          }
  439.       fprintf(db, "\n");
  440.  
  441.       /*
  442.        * Output the "executable" code (includes abstract code) for the
  443.        *   operation.
  444.        */
  445.       put_inlin(db, ip->in_line);
  446.       fprintf(db, "\n$end\n\n");    /* end of operation entry */
  447.       }
  448.    fprintf(db, "$endsect\n\n");     /* end of section for operation type */
  449.    }
  450.  
  451. /*
  452.  * put_inlin - put in-line code into the data base file. This is the
  453.  *   code used by iconc to perform type infernence for the operation
  454.  *   and to generate a taylored version of the operation.
  455.  */
  456. static novalue put_inlin(db, il)
  457. FILE *db;
  458. struct il_code *il;
  459.    {
  460.    int i;
  461.    int num_cases;
  462.    int indx;
  463.  
  464.    /*
  465.     * RTL statements are handled by this function. Other functions
  466.     *  are called for C code.
  467.     */
  468.    if (il == NULL) {
  469.       fprintf(db, "nil ");
  470.       return;
  471.       }
  472.  
  473.    switch (il->il_type) {
  474.       case IL_Const:
  475.          /*
  476.           * Constant keyword.
  477.           */
  478.          fprintf(db, "const ");
  479.          put_typcd(db, il->u[0].n);              /* type  code */
  480.          fprintf(db, "%s ", il->u[1].s);         /* literal */
  481.          break;
  482.       case IL_If1:
  483.          /*
  484.           * if-then statment.
  485.           */
  486.          fprintf(db, "if1 ");
  487.          put_inlin(db, il->u[0].fld);            /* condition */
  488.          fprintf(db, "\n");
  489.          put_inlin(db, il->u[1].fld);            /* then clause */
  490.          break;
  491.       case IL_If2:
  492.          /*
  493.           * if-then-else statment.
  494.           */
  495.          fprintf(db, "if2 ");
  496.          put_inlin(db, il->u[0].fld);            /* condition */
  497.          fprintf(db, "\n");
  498.          put_inlin(db, il->u[1].fld);            /* then clause */
  499.          fprintf(db, "\n");
  500.          put_inlin(db, il->u[2].fld);            /* else clause */
  501.          break;
  502.       case IL_Tcase1:
  503.          /*
  504.           * type_case statement with no default clause.
  505.           */
  506.          fprintf(db, "tcase1 ");
  507.          put_case(db, il);
  508.          break;
  509.       case IL_Tcase2:
  510.          /*
  511.           * type_case statement with a default clause.
  512.           */
  513.          fprintf(db, "tcase2 ");
  514.          indx = put_case(db, il);
  515.          fprintf(db, "\n");
  516.          put_inlin(db, il->u[indx].fld);         /* default */
  517.          break;
  518.       case IL_Lcase:
  519.          /*
  520.           * len_case statement.
  521.           */
  522.          fprintf(db, "lcase ");
  523.          num_cases = il->u[0].n;
  524.          fprintf(db, "%d ", num_cases);
  525.          indx = 1;
  526.          for (i = 0; i < num_cases; ++i) {
  527.             fprintf(db, "\n%d ", il->u[indx++].n);    /* selection number */
  528.             put_inlin(db, il->u[indx++].fld);        /* action */
  529.             }
  530.          fprintf(db, "\n");
  531.          put_inlin(db, il->u[indx].fld);             /* default */
  532.          break;
  533.       case IL_Err1:
  534.          /*
  535.           * runerr with no value arugment.
  536.           */
  537.          fprintf(db, "runerr1 ");
  538.          fprintf(db, "%d ", il->u[0].n);      /* error number */
  539.          break;
  540.       case IL_Err2:
  541.          /*
  542.           * runerr with a value arugment.
  543.           */
  544.          fprintf(db, "runerr2 ");
  545.          fprintf(db, "%d ", il->u[0].n);      /* error number */
  546.          put_inlin(db, il->u[1].fld);          /* variable */
  547.          break;
  548.       case IL_Lst:
  549.          /*
  550.           * "glue" to string statements together.
  551.           */
  552.          fprintf(db, "lst ");
  553.          put_inlin(db, il->u[0].fld);
  554.          fprintf(db, "\n");
  555.          put_inlin(db, il->u[1].fld);
  556.          break;
  557.       case IL_Bang:
  558.          /*
  559.           * ! operator from type checking.
  560.           */
  561.          fprintf(db, "! ");
  562.          put_inlin(db, il->u[0].fld);
  563.          break;
  564.       case IL_And:
  565.          /*
  566.           * && operator from type checking.
  567.           */
  568.          fprintf(db, "&& ");
  569.          put_inlin(db, il->u[0].fld);
  570.          put_inlin(db, il->u[1].fld);
  571.          break;
  572.       case IL_Cnv1:
  573.          /*
  574.           * cnv:<dest-type>(<source>)
  575.           */
  576.          fprintf(db, "cnv1 ");
  577.          put_typcd(db, il->u[0].n);      /* type code */
  578.          put_inlin(db, il->u[1].fld);    /* source */
  579.          break;
  580.       case IL_Cnv2:
  581.          /*
  582.           * cnv:<dest-type>(<source>,<destination>)
  583.           */
  584.          fprintf(db, "cnv2 ");
  585.          put_typcd(db, il->u[0].n);      /* type code */
  586.          put_inlin(db, il->u[1].fld);    /* source */
  587.          put_ilc(db, il->u[2].c_cd);     /* destination */
  588.          break;
  589.       case IL_Def1:
  590.          /*
  591.           * def:<dest-type>(<source>,<default-value>)
  592.           */
  593.          fprintf(db, "def1 ");
  594.          put_typcd(db, il->u[0].n);      /* type code */
  595.          put_inlin(db, il->u[1].fld);    /* source */
  596.          put_ilc(db, il->u[2].c_cd);     /* default value */
  597.          break;
  598.       case IL_Def2:
  599.          /*
  600.           * def:<dest-type>(<source>,<default-value>,<destination>)
  601.           */
  602.          fprintf(db, "def2 ");
  603.          put_typcd(db, il->u[0].n);      /* type code */
  604.          put_inlin(db, il->u[1].fld);    /* source */
  605.          put_ilc(db, il->u[2].c_cd);     /* default value */
  606.          put_ilc(db, il->u[3].c_cd);     /* destination */
  607.          break;
  608.       case IL_Is:
  609.          /*
  610.           * is:<type-name>(<variable>)
  611.           */
  612.          fprintf(db, "is ");
  613.          put_typcd(db, il->u[0].n);      /* type code */
  614.          put_inlin(db, il->u[1].fld);    /* variable */
  615.          break;
  616.       case IL_Var:
  617.          /*
  618.           * A variable.
  619.           */
  620.          fprintf(db, "%d ", il->u[0].n);    /* symbol table index */
  621.          break;
  622.       case IL_Subscr:
  623.          /*
  624.           * A subscripted variable.
  625.           */
  626.          fprintf(db, "[ ");
  627.          fprintf(db, "%d ", il->u[0].n);    /* symbol table index */
  628.          fprintf(db, "%d ", il->u[1].n);    /* subscripting index */
  629.          break;
  630.       case IL_Block:
  631.          /*
  632.           * A block of in-line code. First output a symbol table
  633.           *   of tended variables.
  634.           */
  635.          fprintf(db, "block ");
  636.          fprintf(db, "%d ", il->u[0].n);    /* number of local tended */
  637.          for (i = 1; i <= il->u[0].n; ++i)
  638.              switch (il->u[i].n) {
  639.                 case TndDesc:
  640.                    fprintf(db, "desc ");
  641.                    break;
  642.                 case TndStr:
  643.                    fprintf(db, "str ");
  644.                    break;
  645.                 case TndBlk:
  646.                    fprintf(db, "blkptr ");
  647.                    break;
  648.                 }
  649.          put_ilc(db, il->u[i].c_cd);         /* body of block */
  650.          break;
  651.       case IL_Call:
  652.          /*
  653.           * A call to a body function.
  654.           */
  655.          fprintf(db, "call ");
  656.  
  657.          /*
  658.           * Each body fucntion has a 3rd prefix character to distinish
  659.           *  it from other functions for the operation.
  660.           */
  661.          fprintf(db, "%c ", (char)il->u[1].n);
  662.  
  663.          /*
  664.           * A body function that would only return one possible signal
  665.           *   need return none. In which case, it can directly return a
  666.           *   C integer or double directly rather than using a result
  667.           *   descriptor location. Indicate what it does.
  668.           */
  669.          switch (il->u[2].n) {
  670.             case RetInt:
  671.                fprintf(db, "i ");  /* directly return integer */
  672.                break;
  673.             case RetDbl:
  674.                fprintf(db, "d ");  /* directly return double */
  675.                break;
  676.             case RetNoVal:
  677.                fprintf(db, "n ");  /* return nothing directly */
  678.                break;
  679.             case RetSig:
  680.                fprintf(db, "s ");  /* return a signal */
  681.                break;
  682.             }
  683.  
  684.          /*
  685.           * Output the return/suspend/fail/fall-through flag.
  686.           */
  687.          ret_flag(db, il->u[3].n, 1);
  688.  
  689.          /*
  690.           * Indicate whether the body function expects to have
  691.           *   an explicit result location passed to it.
  692.           */
  693.          if (il->u[4].n)
  694.             fprintf(db, "t ");
  695.          else
  696.             fprintf(db, "f ");
  697.  
  698.          fprintf(db, "%d ", il->u[5].n);    /* num string bufs */
  699.          fprintf(db, "%d ", il->u[6].n);    /* num cset bufs */
  700.          i = il->u[7].n;
  701.          fprintf(db, "%d ", i);             /* num args */
  702.          indx = 8;
  703.          /*
  704.           * output prototype paramater declarations and actual arguments.
  705.           */
  706.          i *= 2;
  707.          while (i--)
  708.             put_ilc(db, il->u[indx++].c_cd);
  709.          break;
  710.       case IL_Abstr:
  711.          /*
  712.           * Abstract type computation.
  713.           */
  714.          fprintf(db, "abstr ");
  715.          put_inlin(db, il->u[0].fld);    /* side effects */
  716.          put_inlin(db, il->u[1].fld);    /* return type */
  717.          break;
  718.       case IL_VarTyp:
  719.          /*
  720.           * type(<parameter>)
  721.           */
  722.          fprintf(db, "vartyp ");
  723.          put_inlin(db, il->u[0].fld);    /* variable */
  724.          break;
  725.       case IL_Store:
  726.          /*
  727.           * store[<type>]
  728.           */
  729.          fprintf(db, "store ");
  730.          put_inlin(db, il->u[0].fld);    /* type to be "dereferenced "*/
  731.          break;
  732.       case IL_LstElm:
  733.          /*
  734.           * <type>.lst_elem
  735.           */
  736.          fprintf(db, "lstelm ");
  737.          put_inlin(db, il->u[0].fld);    /* list type */
  738.          break;
  739.       case IL_SetElm:
  740.          /*
  741.           * <type>.set_elem
  742.           */
  743.          fprintf(db, "setelm ");
  744.          put_inlin(db, il->u[0].fld);    /* set type */
  745.          break;
  746.       case IL_TblKey:
  747.          /*
  748.           * <type>.key
  749.           */
  750.          fprintf(db, "tblkey ");
  751.          put_inlin(db, il->u[0].fld);    /* table type */
  752.          break;
  753.       case IL_TblElm:
  754.          /*
  755.           * <type>.tbl_elem
  756.           */
  757.          fprintf(db, "tblelm ");
  758.          put_inlin(db, il->u[0].fld);    /* table type */
  759.          break;
  760.       case IL_TblDft:
  761.          /*
  762.           * <type>.default
  763.           */
  764.          fprintf(db, "tbldft ");
  765.          put_inlin(db, il->u[0].fld);    /* table type */
  766.          break;
  767.       case IL_Fields:
  768.          /*
  769.           * <type>.all_fields
  770.           */
  771.          fprintf(db, "flds ");
  772.          put_inlin(db, il->u[0].fld);    /* record type */
  773.          break;
  774.       case IL_StrVar:
  775.          /*
  776.           * <type>.str_var
  777.           */
  778.          fprintf(db, "strvar ");
  779.          put_inlin(db, il->u[0].fld);    /* substring trapped variable type */
  780.          break;
  781.       case IL_TrpTbl:
  782.          /*
  783.           * <type>.trpd_tbl
  784.           */
  785.          fprintf(db, "trptbl ");
  786.          put_inlin(db, il->u[0].fld);    /* table elem trapped variable type */
  787.          break;
  788.       case IL_TpAsgn:
  789.          /*
  790.           * store[<variable-type>] = <value-type>
  791.           */
  792.          fprintf(db, "= ");
  793.          put_inlin(db, il->u[0].fld);    /* variable type */
  794.          put_inlin(db, il->u[1].fld);    /* value type */
  795.          break;
  796.       case IL_Union:
  797.          /*
  798.           * <type 1> ++ <type 2>
  799.           */
  800.          fprintf(db, "++ ");
  801.          put_inlin(db, il->u[0].fld);
  802.          put_inlin(db, il->u[1].fld);
  803.          break;
  804.       case IL_Inter:
  805.          /*
  806.           * <type 1> ** <type 2>
  807.           */
  808.          fprintf(db, "** ");
  809.          put_inlin(db, il->u[0].fld);
  810.          put_inlin(db, il->u[1].fld);
  811.          break;
  812.       case IL_New:
  813.          /*
  814.           * new <type-name>(<type 1> , ...)
  815.           */
  816.          fprintf(db, "new ");
  817.          put_typcd(db, il->u[0].n);      /* type code */
  818.          i = il->u[1].n;
  819.          fprintf(db, "%d ", i);          /* num args */
  820.          indx = 2;
  821.          while (i--)
  822.             put_inlin(db, il->u[indx++].fld);
  823.          break;
  824.       case IL_IcnTyp:
  825.          /*
  826.           * <type-name>
  827.           */
  828.          fprintf(db, "typ ");
  829.          put_typcd(db, il->u[0].n);      /* type code */
  830.          break;
  831.       }
  832.    }
  833.  
  834. /*
  835.  * put_case - put the cases of a type_case statement into the data base file.
  836.  */
  837. static int put_case(db, il)
  838. FILE *db;
  839. struct il_code *il;
  840.    {
  841.    int *typ_vect;
  842.    int i, j;
  843.    int num_cases;
  844.    int num_types;
  845.    int indx;
  846.  
  847.    put_inlin(db, il->u[0].fld);               /* expression being checked */
  848.    num_cases = il->u[1].n;                    /* number of cases */
  849.    fprintf(db, "%d ", num_cases);
  850.    indx = 2;
  851.    for (i = 0; i < num_cases; ++i) {
  852.       num_types = il->u[indx++].n;             /* number of types in case */
  853.       fprintf(db, "\n%d ", num_types);
  854.       typ_vect = il->u[indx++].vect;          /* vector of type codes */
  855.       for (j = 0; j < num_types; ++j)
  856.          put_typcd(db, typ_vect[j]);          /* type code */
  857.       put_inlin(db, il->u[indx++].fld);       /* action */
  858.       }
  859.    return indx;
  860.    }
  861.  
  862. /*
  863.  * put_typcd - convert a numeric type code into an alpha type code and
  864.  *  put it in the data base file.
  865.  */
  866. static novalue put_typcd(db, typcd)
  867. FILE *db;
  868. int typcd;
  869.    {
  870.    switch (typcd) {
  871.       case TypEmpty:
  872.          fprintf(db, "e ");    /* empty_type */
  873.          break;
  874.       case TypCset:
  875.          fprintf(db, "c ");    /* cset */
  876.          break;
  877.       case TypReal:
  878.          fprintf(db, "r ");    /* real */
  879.          break;
  880.       case TypInt:
  881.          fprintf(db, "i ");    /* integer */
  882.          break;
  883.       case TypFile:
  884.          fprintf(db, "f ");    /* file */
  885.          break;
  886.       case TypStr:
  887.          fprintf(db, "s ");    /* string */
  888.          break;
  889.       case TypNull:
  890.          fprintf(db, "n ");    /* null */
  891.          break;
  892.       case TypProc:
  893.          fprintf(db, "p ");    /* procedure */
  894.          break;
  895.       case TypCoExp:
  896.          fprintf(db, "C ");    /* co-expression */
  897.          break;
  898.       case TypList:
  899.          fprintf(db, "L ");    /* list */
  900.          break;
  901.       case TypRec:
  902.          fprintf(db, "R ");    /* record */
  903.          break;
  904.       case TypSet:
  905.          fprintf(db, "S ");    /* set */
  906.          break;
  907.       case TypTbl:
  908.          fprintf(db, "T ");    /* table */
  909.          break;
  910.       case TypVar:
  911.          fprintf(db, "v ");    /* varriable */
  912.          break;
  913.       case TypTvStr:
  914.          fprintf(db, "ss ");    /* substring trapped variable */
  915.          break;
  916.       case TypTvTbl:
  917.          fprintf(db, "tt ");    /* table-element trapped variable */
  918.          break;
  919.       case TypKyInt:
  920.          fprintf(db, "ki ");    /* integer keyword variable */
  921.          break;
  922.       case TypKySub:
  923.          fprintf(db, "ks ");    /*  &subject */
  924.          break;
  925.       case TypKyPos:
  926.          fprintf(db, "kp ");    /* &pos */
  927.          break;
  928.       case TypCInt:
  929.          fprintf(db, "ci ");    /* C_integer */
  930.          break;
  931.       case TypCDbl:
  932.          fprintf(db, "cd ");    /* C_double */
  933.          break;
  934.       case TypCStr:
  935.          fprintf(db, "cs ");    /* C_string */
  936.          break;
  937.       case TypEInt:
  938.          fprintf(db, "ei ");    /* (exact)integer) */
  939.          break;
  940.       case TypECInt:
  941.          fprintf(db, "eci ");   /* (exact)C_integer */
  942.          break;
  943.       case TypTStr:
  944.          fprintf(db, "ts ");    /* tmp_string */
  945.          break;
  946.       case TypTCset:
  947.          fprintf(db, "tc ");    /* tmp_cset */
  948.          break;
  949.       case RetDesc:
  950.          fprintf(db, "d ");     /* plain descriptor on return/suspend */
  951.          break;
  952.       case RetNVar:
  953.          fprintf(db, "nv ");    /* named_var */
  954.          break;
  955.       case RetSVar:
  956.          fprintf(db, "sv ");    /* struct_var */
  957.          break;
  958.       case RetNone:
  959.          fprintf(db, "rn ");    /* preset result location on return/suspend */
  960.          break;
  961.       }
  962.    }
  963.  
  964. /*
  965.  * put_ilc - put in-line C code in the data base file.
  966.  */
  967. static novalue put_ilc(db, ilc)
  968. FILE *db;
  969. struct il_c *ilc;
  970.    {
  971.    /*
  972.     * In-line C code is either "nil" or code bracketed by $c $e.
  973.     *   The bracketed code consists of text for C code plus special
  974.     *   constructs starting with $. Control structures have been
  975.     *   translated into gotos in the form of special constructs
  976.     *   (note that case statements are not supported in in-line code).
  977.     */
  978.    if (ilc == NULL) {
  979.       fprintf(db, "nil ");
  980.       return;
  981.       }
  982.    fprintf(db, "$c ");
  983.    while (ilc != NULL) {
  984.       switch(ilc->il_c_type) {
  985.          case ILC_Ref:
  986.             put_var(db, 'r', ilc);   /* non-modifying reference to variable */
  987.             break;
  988.          case ILC_Mod:
  989.             put_var(db, 'm', ilc);   /* modifying reference to variable */
  990.             break;
  991.          case ILC_Tend:
  992.             put_var(db, 't', ilc);   /* variable declared tended */
  993.             break;
  994.          case ILC_SBuf:
  995.             fprintf(db, "$sb ");     /* string buffer for tmp_string */
  996.             break;
  997.          case ILC_CBuf:
  998.             fprintf(db, "$cb ");     /* cset buffer for tmp_cset */
  999.             break;
  1000.          case ILC_Ret:
  1001.             fprintf(db, "$ret ");    /* return statement */
  1002.             put_ret(db, ilc);
  1003.             break;
  1004.          case ILC_Susp:
  1005.             fprintf(db, "$susp ");   /* suspend statement */
  1006.             put_ret(db, ilc);
  1007.             break;
  1008.          case ILC_Fail:
  1009.             fprintf(db, "$fail ");   /* fail statement */
  1010.             break;
  1011.          case ILC_EFail:
  1012.             fprintf(db, "$efail ");  /* errorfail statement */
  1013.             break;
  1014.          case ILC_Goto:
  1015.             fprintf(db, "$goto %d ", ilc->n);  /* goto label */
  1016.             break;
  1017.          case ILC_CGto:
  1018.             fprintf(db, "$cgoto ");            /* contitional goto */
  1019.             put_ilc(db, ilc->code[0]);         /* condition (with $c $e) */
  1020.             fprintf(db, "%d ", ilc->n);        /* label */
  1021.             break;
  1022.          case ILC_Lbl:
  1023.             fprintf(db, "$lbl %d ", ilc->n);   /* label */
  1024.             break;
  1025.          case ILC_LBrc:
  1026.             fprintf(db, "${ ");                /* start of C block with dcls */
  1027.             break;
  1028.          case ILC_RBrc:
  1029.             fprintf(db, "$} ");                /* end of C block with dcls */
  1030.             break;
  1031.          case ILC_Str:
  1032.             fprintf(db, "%s", ilc->s);         /* C code as plain text */
  1033.             break;
  1034.          }
  1035.       ilc = ilc->next;
  1036.       }
  1037.    fprintf(db, " $e ");
  1038.    }
  1039.  
  1040. /*
  1041.  * put_var - output in-line C code for a variable.
  1042.  */
  1043. static novalue put_var(db, code, ilc)
  1044. FILE *db;
  1045. int code;
  1046. struct il_c *ilc;
  1047.    {
  1048.    fprintf(db, "$%c", code);  /* 'r': non-mod ref, 'm': mod ref, 't': tended */
  1049.    if (ilc->s != NULL)
  1050.       fprintf(db, "%s", ilc->s);  /* access into descriptor */
  1051.    if (ilc->n == RsltIndx)
  1052.       fprintf(db, "r ");          /* this is "result" */
  1053.    else
  1054.       fprintf(db, "%d ", ilc->n); /* offset into a symbol table */
  1055.    }
  1056.  
  1057. /*
  1058.  * ret_flag - put a return/suspend/fail/fall-through flag in the data base
  1059.  *  file.
  1060.  */
  1061. static novalue ret_flag(db, flag, may_fthru)
  1062. FILE *db;
  1063. int flag;
  1064. int may_fthru;
  1065.    {
  1066.    if (flag & DoesFail)
  1067.       fprintf(db, "f");      /* can fail */
  1068.    else
  1069.       fprintf(db, "_");      /* cannot fail */
  1070.    if (flag & DoesRet)
  1071.       fprintf(db, "r");      /* can return */
  1072.    else
  1073.       fprintf(db, "_");      /* cannot return */
  1074.    if (flag & DoesSusp)
  1075.       fprintf(db, "s");      /* can suspend */
  1076.    else
  1077.       fprintf(db, "_");      /* cannot suspend */
  1078.    if (flag & DoesEFail)
  1079.       fprintf(db, "e");      /* can do error conversion */
  1080.    else
  1081.       fprintf(db, "_");      /* cannot do error conversion */
  1082.    if (may_fthru)            /* body functions only: */
  1083.       if (flag & DoesFThru)
  1084.          fprintf(db, "t");      /* can fall through */
  1085.       else
  1086.          fprintf(db, "_");      /* cannot fall through */
  1087.   fprintf(db, " ");
  1088.   }
  1089.  
  1090. /*
  1091.  * put_ret - put the body of a return/suspend statement in the data base.
  1092.  */
  1093. static novalue put_ret(db, ilc)
  1094. FILE *db;
  1095. struct il_c *ilc;
  1096.    {
  1097.    int i;
  1098.  
  1099.    /*
  1100.     * Output the type of descriptor constructor on the return/suspend,
  1101.     *  then output the the number of arguments to the constructor, and
  1102.     *  the arguments themselves.
  1103.     */
  1104.    put_typcd(db, ilc->n);
  1105.    for (i = 0; i < 3 && ilc->code[i] != NULL; ++i)
  1106.        ;
  1107.    fprintf(db, "%d ", i);
  1108.    for (i = 0; i < 3 && ilc->code[i] != NULL; ++i)
  1109.        put_ilc(db, ilc->code[i]);
  1110.    }
  1111.  
  1112. /*
  1113.  * name_cmp - compare implementation structs by name; function used as
  1114.  *  an argument to qsort().
  1115.  */
  1116. static int name_cmp(p1, p2)
  1117. char *p1;
  1118. char *p2;
  1119.    {
  1120.    register struct implement *ip1;
  1121.    register struct implement *ip2;
  1122.  
  1123.    ip1 = *(struct implement **)p1;
  1124.    ip2 = *(struct implement **)p2;
  1125.    return strcmp(ip1->name, ip2->name);
  1126.    }
  1127.  
  1128. /*
  1129.  * op_cmp - compare implementation structs by operator and number of args;
  1130.  *   function used as an argument to qsort().
  1131.  */
  1132. static int op_cmp(p1, p2)
  1133. char *p1;
  1134. char *p2;
  1135.    {
  1136.    register int cmp;
  1137.    register struct implement *ip1;
  1138.    register struct implement *ip2;
  1139.  
  1140.    ip1 = *(struct implement **)p1;
  1141.    ip2 = *(struct implement **)p2;
  1142.  
  1143.    cmp = strcmp(ip1->op, ip2->op);
  1144.    if (cmp == 0)
  1145.       return ip1->nargs - ip2->nargs;
  1146.    else
  1147.       return cmp;
  1148.    }
  1149.  
  1150. /*
  1151.  * prt_dpnd - print dependency information to the data base.
  1152.  */
  1153. static novalue prt_dpnd(db)
  1154. FILE *db;
  1155.    {
  1156.    struct srcfile **sort_ary;
  1157.    struct srcfile *sfile;
  1158.    unsigned hashval;
  1159.    int line_left;
  1160.    int num;
  1161.    int i;
  1162.  
  1163.    fprintf(db, "\ndependencies\n\n");  /* start of dependency section */
  1164.  
  1165.    /*
  1166.     * sort the dependency information by source file name.
  1167.     */
  1168.    sort_ary =
  1169.      (struct srcfile **)alloc((unsigned int)(num_src*sizeof(struct srcfile *)));
  1170.    num = 0;
  1171.    for (hashval = 0; hashval < DHSize; ++hashval)
  1172.       for (sfile = dhash[hashval]; sfile != NULL; sfile = sfile->next)
  1173.          sort_ary[num++] = sfile;
  1174.    qsort((char *)sort_ary, num, sizeof(struct srcfile *),
  1175.       (int (*)())src_cmp);
  1176.  
  1177.    /*
  1178.     * For each source file with dependants, output the source file
  1179.     *  name followed by the list of depedent files. The list is
  1180.     *  terminated with "end".
  1181.     */
  1182.    for (i = 0; i < num; ++i) {
  1183.       sfile = sort_ary[i];
  1184.       if (sfile->dependents != NULL) {
  1185.          fprintf(db, "%-12s  ", sfile->name);
  1186.          line_left = prt_c_fl(db, sfile->dependents, MaxLine - 14);
  1187.          if (line_left - 4 < 0)
  1188.             fprintf(db, "\n            ");
  1189.          fprintf(db, "$end\n");
  1190.          }
  1191.       }
  1192.    fprintf(db, "\n$endsect\n");  /* end of dependency section */
  1193.    free((char *)sort_ary);
  1194.    }
  1195.  
  1196. /*
  1197.  * src_cmp - compare srcfile structs; function used as an argument to qsort().
  1198.  */
  1199. static int src_cmp(p1, p2)
  1200. char *p1;
  1201. char *p2;
  1202.    {
  1203.    register struct srcfile *sp1;
  1204.    register struct srcfile *sp2;
  1205.  
  1206.    sp1 = *(struct srcfile **)p1;
  1207.    sp2 = *(struct srcfile **)p2;
  1208.    return strcmp(sp1->name, sp2->name);
  1209.    }
  1210.  
  1211. /*
  1212.  * prt_c_fl - print list of C files in reverse order.
  1213.  */
  1214. static int prt_c_fl(db, clst, line_left)
  1215. FILE *db;
  1216. struct cfile *clst;
  1217. int line_left;
  1218.    {
  1219.    int len;
  1220.  
  1221.    if (clst == NULL)
  1222.       return line_left;
  1223.    line_left = prt_c_fl(db, clst->next, line_left);
  1224.  
  1225.    /*
  1226.     * If this will exceed the line length, print a new-line and some
  1227.     *  leading white space.
  1228.     */
  1229.    len = strlen(clst->name) + 1;
  1230.    if (line_left - len < 0) {
  1231.       fprintf(db, "\n              ");
  1232.       line_left = MaxLine - 14;
  1233.       }
  1234.    fprintf(db, "%s ", clst->name);
  1235.    return line_left - len;
  1236.    }
  1237. #endif                    /* Rttx */
  1238.  
  1239. /*
  1240.  * full_lst - print a full list of all files produced by translations
  1241.  *  as represented in the dependencies section of the data base.
  1242.  */
  1243. novalue full_lst(fname)
  1244. char *fname;
  1245.    {
  1246.    unsigned hashval;
  1247.    struct srcfile *sfile;
  1248.    struct cfile *clst;
  1249.    struct fileparts *fp;
  1250.    FILE *f;
  1251.  
  1252.    f = fopen(fname, "w");
  1253.    if (f == NULL)
  1254.       err2("cannot open ", fname);
  1255.    for (hashval = 0; hashval < DHSize; ++hashval)
  1256.       for (sfile = dhash[hashval]; sfile != NULL; sfile = sfile->next)
  1257.          for (clst = sfile->dependents; clst != NULL; clst = clst->next) {
  1258.             /*
  1259.              * Remove the suffix from the name before printing.
  1260.              */
  1261.             fp = fparse(clst->name);
  1262.             fprintf(f, "%s\n", fp->name);
  1263.             }
  1264.    fclose(f);
  1265.    }
  1266.  
  1267. /*
  1268.  * impl_fnc - find or create implementation struct for function currently
  1269.  *  being parsed.
  1270.  */
  1271. novalue impl_fnc(name)
  1272. struct token *name;
  1273.    {
  1274.    /*
  1275.     * Set the global operation type for later use. If this is a
  1276.     *  new function update the number of them.
  1277.     */
  1278.    op_type = Function;
  1279.    num_fnc = set_impl(name, bhash, num_fnc, fnc_pre);
  1280.    }
  1281.  
  1282. /*
  1283.  * impl_key - find or create implementation struct for keyword currently
  1284.  *  being parsed.
  1285.  */
  1286. novalue impl_key(name)
  1287. struct token *name;
  1288.    {
  1289.    /*
  1290.     * Set the global operation type for later use. If this is a
  1291.     *  new keyword update the number of them.
  1292.     */
  1293.    op_type = Keyword;
  1294.    num_key = set_impl(name, khash, num_key, key_pre);
  1295.    }
  1296.  
  1297. /*
  1298.  * set_impl - lookup a function or keyword in a hash table and update the
  1299.  *  entry, creating the entry if needed.
  1300.  */
  1301. static int set_impl(name, tbl, num_impl, pre)
  1302. struct token *name;
  1303. struct implement **tbl;
  1304. int num_impl;
  1305. char *pre;
  1306.    {
  1307.    register struct implement *ptr;
  1308.    char *name_s;
  1309.    unsigned hashval;
  1310.  
  1311.    /*
  1312.     * we only need the operation name and not the entire token.
  1313.     */
  1314.    name_s = name->image;
  1315.    free_t(name);
  1316.  
  1317.    /*
  1318.     * If the operation is not in the hash table, put it there.
  1319.     */
  1320.    if ((ptr = db_ilkup(name_s, tbl)) == NULL) {
  1321.       ptr = NewStruct(implement);
  1322.       hashval = IHasher(name_s);
  1323.       ptr->blink = tbl[hashval];
  1324.       ptr->oper_typ = ((op_type == Function) ? 'F' : 'K');
  1325.       nxt_pre(ptr->prefix, pre);    /* allocate a unique prefix */
  1326.       ptr->name = name_s;
  1327.       ptr->op = NULL;
  1328.       tbl[hashval] = ptr;
  1329.       ++num_impl;
  1330.       }
  1331.  
  1332.    cur_impl = ptr;   /* put entry in global variable for later access */
  1333.  
  1334.    /*
  1335.     * initialize the entry based on global information set during parsging.
  1336.     */
  1337.    set_prms(ptr);
  1338.    ptr->min_result = min_rs;
  1339.    ptr->max_result = max_rs;
  1340.    ptr->resume = rsm_rs;
  1341.    ptr->ret_flag = 0;
  1342.    if (comment == NULL)
  1343.       ptr->comment = "";
  1344.    else {
  1345.       ptr->comment = comment->image;
  1346.       free_t(comment);
  1347.       comment = NULL;
  1348.       }
  1349.    ptr->ntnds = 0;
  1350.    ptr->tnds = NULL;
  1351.    ptr->nvars = 0;
  1352.    ptr->vars = NULL;
  1353.    ptr->in_line = NULL;
  1354.    ptr->iconc_flgs = 0;
  1355.    return num_impl;
  1356.    }
  1357.  
  1358. /*
  1359.  * set_prms - set the parameter information of an implementation based on
  1360.  *   the params list constructed during parsing.
  1361.  */
  1362. static novalue set_prms(ptr)
  1363. struct implement *ptr;
  1364.    {
  1365.    struct sym_entry *sym;
  1366.    int nargs;
  1367.    int i;
  1368.  
  1369.    /*
  1370.     * Create an array of parameter flags for the operation. The flag
  1371.     * indicates the deref/underef and varargs status for each parameter.
  1372.     */
  1373.    if (params == NULL) {
  1374.       ptr->nargs = 0;
  1375.       ptr->arg_flgs = NULL;
  1376.       }
  1377.    else {
  1378.       /*
  1379.        * The parameters are in reverse order, so the number of the parameters
  1380.        *  can be determined by the number assigned to the first one on the
  1381.        *  list.
  1382.        */
  1383.       nargs = params->u.param_info.param_num + 1;
  1384.       ptr->nargs = nargs;
  1385.       ptr->arg_flgs = (int *)alloc((unsigned int)(sizeof(int) * nargs));
  1386.       for (i = 0; i < nargs; ++i)
  1387.          ptr->arg_flgs[i] = 0;
  1388.       for (sym = params; sym != NULL; sym = sym->u.param_info.next)
  1389.          ptr->arg_flgs[sym->u.param_info.param_num] |= sym->id_type;
  1390.       }
  1391.    }
  1392.  
  1393. /*
  1394.  * impl_op - find or create implementation struct for operator currently
  1395.  *  being parsed.
  1396.  */
  1397. novalue impl_op(op_sym, name)
  1398. struct token *op_sym;
  1399. struct token *name;
  1400.    {
  1401.    register struct implement *ptr;
  1402.    char *op;
  1403.    int nargs;
  1404.    unsigned hashval;
  1405.  
  1406.    /*
  1407.     * The operator symbol is needed but not the entire token.
  1408.     */
  1409.    op = op_sym->image;
  1410.    free_t(op_sym);
  1411.  
  1412.    /*
  1413.     * The parameters are in reverse order, so the number of the parameters
  1414.     *  can be determined by the number assigned to the first one on the
  1415.     *  list.
  1416.     */
  1417.    if (params == NULL)
  1418.       nargs = 0;
  1419.    else
  1420.       nargs = params->u.param_info.param_num + 1;
  1421.  
  1422.    /*
  1423.     * Locate the operator in the hash table; it must match both the
  1424.     *  operator symbol and the number of arguments. If the operator is
  1425.     *  not there, create an entry.
  1426.     */
  1427.    hashval = IHasher(op);
  1428.    ptr = ohash[hashval];
  1429.    while (ptr != NULL && (ptr->op != op || ptr->nargs != nargs))
  1430.       ptr = ptr->blink;
  1431.    if (ptr == NULL) {
  1432.       ptr = NewStruct(implement);
  1433.       ptr->blink = ohash[hashval];
  1434.       ptr->oper_typ = 'O';
  1435.       nxt_pre(ptr->prefix, op_pre);   /* allocate a unique prefix */
  1436.       ptr->op = op;
  1437.       ohash[hashval] = ptr;
  1438.       ++num_op;
  1439.       }
  1440.  
  1441.    /* 
  1442.     * Put the entry and operation type in global variables for
  1443.     *  later access.
  1444.     */
  1445.    cur_impl = ptr;
  1446.    op_type = Operator;
  1447.  
  1448.    /*
  1449.     * initialize the entry based on global information set during parsging.
  1450.     */
  1451.    ptr->name = name->image;
  1452.    free_t(name);
  1453.    set_prms(ptr);
  1454.    ptr->min_result = min_rs;
  1455.    ptr->max_result = max_rs;
  1456.    ptr->resume = rsm_rs;
  1457.    ptr->ret_flag = 0;
  1458.    if (comment == NULL)
  1459.       ptr->comment = "";
  1460.    else {
  1461.       ptr->comment = comment->image;
  1462.       free_t(comment);
  1463.       comment = NULL;
  1464.       }
  1465.    ptr->ntnds = 0;
  1466.    ptr->tnds = NULL;
  1467.    ptr->nvars = 0;
  1468.    ptr->vars = NULL;
  1469.    ptr->in_line = NULL;
  1470.    ptr->iconc_flgs = 0;
  1471.    }
  1472.  
  1473. /*
  1474.  * set_r_seq - save result sequence information for updating the
  1475.  *  operation entry.
  1476.  */
  1477. novalue set_r_seq(min, max, resume)
  1478. long min;
  1479. long max;
  1480. int resume;
  1481.    {
  1482.    if (min == UnbndSeq)
  1483.       min = 0;
  1484.    min_rs = min;
  1485.    max_rs = max;
  1486.    rsm_rs = resume;
  1487.    }
  1488.  
  1489.